home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
t3_1
/
risc_src.lha
/
risc_sources
/
sys
/
gc_top.t
< prev
next >
Wrap
Text File
|
1990-06-15
|
8KB
|
220 lines
(herald gc_top
(env tsys (osys gc)
(osys gc_weak) ;; for the GC-WEAK-???-LISTs
(osys frame) ;; vframe stuff (temporary)
(osys table))) ;; %TABLE-VECTOR must be integrated here
;;; Copyright (c) 1985 Yale University
;;; Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale University Computer
;;; Science Department. Permission to copy this software, to redistribute it,
;;; and to use it for any purpose is granted, subject to the following restric-
;;; tions and understandings.
;;; 1. Any copy made of this software must include this copyright notice in full.
;;; 2. Users of this software agree to make their best efforts (a) to return
;;; to the T Project at Yale any improvements or extensions that they make,
;;; so that these may be included in future releases; and (b) to inform
;;; the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;; shall duly acknowledge such use, in accordance with the usual standards
;;; of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;; this software will be error-free, and Yale is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Yale University nor of any
;;; adaptation thereof in any advertising, promotional, or sales literature
;;; without prior written consent from Yale in each case.
;;;
(lset *old-space* nil)
(lset *new-space* nil)
(define-simple-switch gc-noisily? boolean? '#f)
(lset *pre-gc-agenda*
(list pre-gc-fix-weak-sets
pre-gc-fix-weak-alists
pre-gc-fix-weak-tables
))
(lset *post-gc-agenda*
(list post-gc-fix-weak-tables
post-gc-fix-weak-sets ; fix any new ones
post-gc-fix-weak-alists
; object-unhash-post-gc
))
;;; GC sensitive things:
;;; PRE POST
;;; weaks + +
;;; vcells + +
;;; populations + GC-UPDATE-THE-POPULATIONS
;;; tables
;;; pools + POOL-PRE-GC-HOOK
;;; streams +
;;; free list + PAIR-FREELIST-PRE-GC-HOOK
(lset *gc-problem?* nil)
(lset *gc-problem?-default* nil)
(define-operation (synch-area area))
(define-operation (reset-area area))
(define-operation (write-area area))
(define-integrable (incr-area-frontier area length)
(set (area-frontier area) (fx+ (area-frontier area) length)))
(define-integrable (area-extent area)
(fx- (area-frontier area) (area-begin area)))
(define-structure-type area
id
uid ; for gc debugging (id,uid) must come first
size
base ; base of area as an extend - see GC-FLIP
begin ; base of area as a fixnum
frontier ;++ changed from POINTER
limit ; consing beyond this point causes a GC
(((reset-area self)
(if (eq? self (current-area))
(error "(reset-area ~s): area is current" self))
(set (area-base self) 0)
(zero-out-area self)
(set (area-frontier self) (area-begin self)))
((synch-area self)
(if (neq? self (current-area))
(error "(synch-area ~s): area is not current" self))
(set (area-frontier self) (system-global slink/area-frontier)))
((write-area self fd)
(vm-write-block fd (area-base self) (area-extent self)))
((print-type-string self) "Area")
((identification self) (area-id self))))
;++flush uid ar
(define (create-area id begin size uid)
(let ((area (make-area)))
(set (area-begin area) begin)
(set (area-frontier area) begin)
(set (area-limit area) (fx+ begin size))
(set (area-id area) id)
(set (area-uid area) uid)
(set (area-size area) size)
area))
(define-integrable (current-area)
(system-global slink/area))
(define (area-space-remaining)
(fx- (area-limit (current-area))
(system-global slink/area-frontier)))
(define (really-gc stack gc-frame)
(let ((z *z?*)
(noise? (gc-noisily?)))
(set *z?* t)
(set *gc-problem?* *gc-problem?-default*)
(if noise? (gc-write-line ";Beginning GC"))
(walk1 (lambda (item) (item)) *pre-gc-agenda*)
(if noise? (gc-write-line ";*PRE-GC-AGENDA* done"))
(gc-flip)
(if noise? (gc-write-line ";GC-FLIP done"))
(set (system-global slink/pair-freelist) nil)
(set (system-global slink/snapper-freelist) nil)
(flush-code-vectors)
(if noise? (gc-write-line ";Starting to root"))
(gc-root stack gc-frame)
;; The next line can't happen until after GC, when the area-object
;; has been moved to new space.
(set (system-global slink/area) *new-space*)
(walk1 (lambda (item) (item)) *post-gc-agenda*)
(if noise? (gc-write-line ";*POST-GC-AGENDA* done"))
(set *z?* z)
(gc-done)
(if noise? (gc-write-line ";GC done"))
(if *gc-problem?* (breakpoint 'really-gc t-implementation-env))))
(define (gc-flip)
(exchange *old-space* *new-space*)
(synch-area *old-space*)
(set (system-global slink/old-space-begin) (area-begin *old-space*))
(set (system-global slink/old-space-frontier) (area-frontier *old-space*))
(set (system-global slink/area-frontier) (area-begin *new-space*))
(set (system-global slink/area-begin) (area-begin *new-space*))
(set (system-global slink/area-limit) (area-limit *new-space*))
(set (area-base *new-space*) (make-vector 0))
; (advise-impure-area-access 'gc)
; (advise-area-access *new-space* 'gc)
)
(define (gc-done)
; (advise-impure-area-access 'random)
; (advise-area-access *new-space* 'random)
(increment-gc-stamp)
(reset-area *old-space*)
; (format t "; ~D objects copied~%" (fx+ *gc-click* *gc-object-count*))
(let ((free (fx- (system-global slink/area-limit)
(system-global slink/area-frontier)))
(total (fx- (system-global slink/area-limit)
(system-global slink/area-begin))))
(if (gc-noisily?) (gc-write-line (format nil ";Space Remaining: ~D left out of ~D (~D% free)"
free total
(->integer (+ .5 (* 1.0 (/ (* 100.0 free) total)))))))))
(define (gc-root stack gc-frame)
(gc-scan-initial-impure-area)
(gc-scan-stack stack (system-global slink/stack))
(scan-gc-frame gc-frame)
; (gc-write-line ";Root set traced")
(gc-scan-active-heap)
; (gc-write-line ";Heap traced")
)
(define (gc-scan-stack frame bottom)
(cond ((fx> frame bottom))
(else
(cond ((frame? frame)
(let ((tem (extend-header frame)))
(if (in-old-space? tem)
(set (extend-header frame)
(gc-extend->pair (gc-extend->pair
(gc-copy-template (gc-pair->extend
(gc-pair->extend tem))))))))
(let ((size (frame-size frame)))
(trace-pointers frame size)
(gc-scan-stack (make-pointer frame size) bottom)))
(else
(gc-error-message "weird thing on stack" frame)
(gc-scan-stack (make-pointer frame 0) bottom))))))
(define (scan-gc-frame frame)
(trace-pointers frame (fx+ *argument-registers* 5)))
(define (scan-interrupt-frame frame)
(trace-pointers frame (fx+ *argument-registers* 6)))
(define (trace-pointers obj ptrs)
(do ((i 0 (fx+ i 1)))
((fx>= i ptrs) t)
(modify (extend-elt obj i) maybe-copy-object)))
;;; True if an object is in old space.
(define (flush-code-vectors)
(iterate loop ((l (weak-set-elements code-population)))
(cond ((null? l))
((in-old-space? (car l))
(flush-code-from-icache (car l))
(loop (cdr l)))
(else (loop (cdr l))))))
(define (gc-write-line string)
(fresh-line (error-output))
(write-string (error-output) string)
(newline (error-output)))
(set (gc-present?) '#t)